PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/pleas/ole/samples.frm

Visual Basic Form | 1994-06-13 | 8.6 KB | 291 lines

VERSION 2.00
Begin Form Form1
   Caption         =   "OA Samples"
   ClientHeight    =   3675
   ClientLeft      =   285
   ClientTop       =   1215
   ClientWidth     =   3690
   Height          =   4080
   Left            =   225
   LinkTopic       =   "Form1"
   ScaleHeight     =   3675
   ScaleWidth      =   3690
   Top             =   870
   Width           =   3810
   Begin TextBox Text1
      Height          =   1095
      Left            =   1680
      MultiLine       =   -1  'True
      TabIndex        =   7
      Text            =   "Text1"
      Top             =   2520
      Width           =   1935
   End
   Begin CommandButton Command7
      Caption         =   "Draw Stuff"
      Height          =   375
      Left            =   360
      TabIndex        =   6
      Top             =   3000
      Width           =   1215
   End
   Begin CommandButton Command6
      Caption         =   "Word Dialog"
      Height          =   375
      Left            =   360
      TabIndex        =   5
      Top             =   2520
      Width           =   1215
   End
   Begin CommandButton Command5
      Caption         =   "Solver"
      Height          =   375
      Left            =   360
      TabIndex        =   4
      Top             =   2040
      Width           =   1215
   End
   Begin CommandButton Command4
      Caption         =   "Debug"
      Height          =   375
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   1215
   End
   Begin CommandButton Command3
      Caption         =   "Amortization"
      Height          =   375
      Left            =   360
      TabIndex        =   2
      Top             =   1560
      Width           =   1215
   End
   Begin CommandButton Command2
      Caption         =   "XL Dialog"
      Height          =   375
      Left            =   360
      TabIndex        =   1
      Top             =   1080
      Width           =   1215
   End
   Begin CommandButton Command1
      Caption         =   "XL Simple"
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   600
      Width           =   1215
   End
Sub Command1_Click ()
' 1. stuffs a label and some values in cells
' 2. creates a named range
' 3. creates a formula
' 4. and stores the Value in the VB variable foo
' Declarations
Dim XL As object
Dim APPXL As object
Dim ws As object
Dim cell As object
' Code
Set XL = GetObject(, "Excel.Application")
Set APPXL = XL.Application
APPXL.Workbooks.Add
Set ws = APPXL.ActiveSheet
ws.Cells(1, 1).Value = "Test"
ws.Cells(2, 1).Value = 100
ws.Range("A2:A5").FillDown
tmp = ws.Range("A1:B5").CreateNames(True, False, False, False)
Set cell = ws.Range("A6")
cell.FormulaR1C1 = "=SUM(Test)"
foo = cell.Value
Set cell = Nothing
Set ws = Nothing
Set XL = Nothing
Set APPXL = Nothing
End Sub
Sub Command2_Click ()
' Calling an Excel dialog from VB
' 1. create an Excel workbook called SHEETS.XLS
' 2. open a dialog sheet
' 3. add a listbox
Dim APPXL As object
Dim XL As object
Dim wb As object
Dim dlg As object
Dim dlgList As object
Dim objList As object
Set APPXL = GetObject(, "Excel.Application")
Set XL = APPXL.Application
XL.Workbooks.Open "C:\TEMP\TEST.XLS"
Set wb = XL.ActiveWorkbook
Set dlg = wb.DialogSheets("dialog1")
Set dlgList = dlg.ListBoxes("SheetsList")
Set objList = wb.Sheets
dlgList.RemoveAllItems
dlg.DialogFrame.Caption = "List of Sheets"
For ix = 1 To objList.Count
    dlgList.[AddItem] (objList(ix).Name)
dlg.[Show]
Set dlg = Nothing
Set dlgList = Nothing
Set objList = Nothing
Set wb = Nothing
Set XL = Nothing
Set APPXL = Nothing
End Sub
Sub Command3_Click ()
' 1. opens AMORTIZE.XLS
' 2. plugs in values for the variables
' 3. and pops the calculated payment up in a message box
'   C7  =Loan_amount
'   C8  =Annual_interest_rate
'   C9  =Term_in_years
'   C10 =Payments_per_year
'   C14 =Calculated_payment
Dim APPXL As object
Dim XL As object
Dim ws As object
Set APPXL = GetObject(, "Excel.Application")
Set XL = APPXL.Application
XL.Workbooks.Open "C:\WINDOWS\EXCEL\EXAMPLES\AMORT.XLS"
Set ws = XL.ActiveSheet
ws.Range("Loan_amount").Value = 100000
ws.Range("Annual_interest_rate").Value = .075
ws.Range("Term_in_years").Value = 30
ws.Range("Payments_per_year").Value = 12
MsgBox Format$(ws.Range("Calculated_payment").Value, "currency"), , "Payment"
XL.Workbooks(1).[Close] (False)
Set ws = Nothing
Set XL = Nothing
Set APPXL = Nothing
End Sub
Sub Command4_Click ()
Dim XL As object
Dim APPXL As object
Dim ws As object
Dim sheet As object
Dim cell As object
Dim zot As object
Dim zot1 As object
Dim zot2 As object
Dim zot3 As object
Dim zot4 As object
Dim zot5 As object
Print XL.Parent
Print XL.Name
Print ws.Range("Test").Value(3)
Print ws.Selection
Print ws.Parent.Name
Print ws.Range("test").Parent.Name
Print APPXL.Parent
Print APPXL.Workbooks.Count
Print APPXL.Worksheets.Count
'====================================
Print APPXL.Worksheets.Count
'====================================
Set XL = GetObject(, "Excel.Application")
Set APPXL = XL.Application
APPXL.WindowState = 3
APPXL.Workbooks.Add
Set ws = APPXL.ActiveSheet
ws.Cells(1, 1).Value = "Test"
ws.Cells(2, 1).Value = 100
ws.Range("A2:A5").FillDown
tmp = ws.Range("A1:B5").CreateNames(True, False, False, False)
Set cell = ws.Range("A6")
cell.FormulaR1C1 = "=SUM(Test)"
Print cell.Value
'=====================================
ws.Range("Foo").Cells(1, 1).Value = 3
Print ws.Cells(1, 1).Value
End Sub
Sub Command5_Click ()
Dim APPXL As object
Dim XL As object
Dim ws As object
Set APPXL = GetObject(, "Excel.Application")
Set XL = APPXL.Application
XL.Workbooks.Open "C:\WINDOWS\EXCEL\EXAMPLES\SOLVER\SOLVEREX.XLS"
Set ws = XL.ActiveSheet
oldP$ = ws.Range("$F$14").Value
XL.ExecuteExcel4Macro "[SOLVER.XLA]SOLVER!SOLVER.OK(!R10C6,1,0,)"
XL.ExecuteExcel4Macro "[SOLVER.XLA]SOLVER!SOLVER.ADD(!R10C6,1,""=40000"")"
XL.ExecuteExcel4Macro "[SOLVER.XLA]SOLVER!SOLVER.OK(!R14C6,1,0,(!R10C2:R10C5))"
XL.ExecuteExcel4Macro "[SOLVER.XLA]SOLVER!SOLVER.SOLVE(True)"
newP$ = ws.Range("$F$14").Value
MsgBox "Old: " & Format(oldP$, "currency") & Chr$(10) & "New: " & Format(newP$, "currency"), , "Profit"
XL.Workbooks(1).[Close] (False)
Set ws = Nothing
Set XL = Nothing
Set APPXL = Nothing
End Sub
Sub Command6_Click ()
    Dim doc As object
    ' Copies the textbox into a new Word document
    ClipBoard.SetText text1.Text
    Set doc = CreateObject("word.basic")
    doc.FileOpen "C:\TEMP\FOO.DOC"
    doc.FileNewDefault
    doc.EditPaste
    ' Creates / overwrites a new Word macro "Counter"
    doc.ToolsMacro "Counter", 0, 1
    doc.EditSelectAll
    doc.EditClear
    doc.Insert "Sub MAIN"
    doc.InsertPara
    doc.Insert "ToolsWordCount"
    doc.InsertPara
    doc.Insert "Dim dlg As ToolsWordCount"
    doc.InsertPara
    doc.Insert "GetCurValues dlg"
    doc.InsertPara
    doc.Insert "MsgBox ""Current word count:"" + dlg.Words"
    doc.InsertPara
    doc.Insert "End Sub"
    doc.FileClose 1
    ' Runs the macro, manipulates the return message (a hack)
    On Error Resume Next
    doc.ToolsMacro "Counter", 1, 0
    MsgBox Right$(Error$, Len(Error$) - 22)
    ' Cleans up
    doc.FileClose 2
    Set doc = Nothing
End Sub
Sub Command7_Click ()
    Dim appvisio As object
    Dim obj1 As object
    Dim obj2 As object
    Dim obj3 As object
    Dim obj4 As object
    Dim obj5 As object
    Set appvisio = CreateObject("visio.application")
    Set obj1 = appvisio.Documents
    obj1.Open ("c:\windows\visio\template\basic.vst")
    Set obj1 = appvisio.ActiveDocument.Pages(1)
    Set obj2 = appvisio.Documents(2)    ' Stencil sheet
    Set obj3 = obj2.Masters             ' Collection of shapes
    Set obj4 = obj3.Item(27)           ' Rectangle
    Set obj5 = obj1.drop(obj4, 2, 5)
    obj5.Text = "One"
    Set obj5 = obj1.drop(obj4, 4, 5)
    obj5.Text = "Two"
    Set obj5 = obj1.drop(obj4, 6, 5)
    obj5.Text = "Three"
    Set obj5 = obj1.drop(obj4, 4, 7)
    obj5.Text = "Main"
    Set obj4 = obj3.Item(21)           ' Top to Bottom
    Set obj5 = obj1.drop(obj4, 4.5, 6)
    obj5.SetEnd 2, 2
    Set obj5 = obj1.drop(obj4, 4.5, 6)
    obj5.SetEnd 4, 4
    Set obj5 = obj1.drop(obj4, 4.5, 6)
    obj5.SetEnd 6, 6
    Set obj5 = Nothing
    Set obj4 = Nothing
    Set obj3 = Nothing
    Set obj2 = Nothing
    Set obj1 = Nothing
    Set appvisio = Nothing
End Sub